home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Delphi Programmer's Power Pack
/
Delphi Volume 1.iso
/
s_to_z
/
subdatab
/
d2unit1.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-09-15
|
6KB
|
239 lines
unit D2unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls, Buttons, Subdatab,
DemoStat;
type
TForm1 = class(TForm)
Panel4: TPanel;
BitBtnClose: TBitBtn;
Button7: TButton;
ButtonStatus: TButton;
ButtonReorg: TButton;
SUBDataBase1: TSUBDataBase;
Panel1: TPanel;
Buttondelete: TButton;
ListBox1: TListBox;
Button1: TButton;
procedure ButtonaddClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BitBtnCloseClick(Sender: TObject);
procedure ButtonStatusClick(Sender: TObject);
procedure ButtondeleteClick(Sender: TObject);
procedure SUBDataBase1Create(Sender: TObject);
procedure ButtonReorgClick(Sender: TObject);
procedure SUBDataBase1Reorg(Sender: TObject; ReorgAct: Longint);
procedure ButtonshowClick(Sender: TObject);
private
{ Private-Deklarationen }
added : longint;
showfirst : Boolean;
procedure Showreccount;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
Type TTestDataRecord = record
Name : String[10];
Firstname : String[15];
anid : longint;
useit : string[30];
end;
Const Index_Demo2 = 'DEMO2';
{----------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
begin
SUBDataBase1.open;
added := 0;
showfirst := true;
randomize;
showreccount;
end;
{----------------------------------------------------------------}
procedure TForm1.FormDestroy(Sender: TObject);
begin
SUBDataBase1.Close;
end;
{----------------------------------------------------------------}
procedure TForm1.BitBtnCloseClick(Sender: TObject);
begin
close;
end;
{----------------------------------------------------------------}
procedure TForm1.ButtonaddClick(Sender: TObject);
var FTestData : TTestDatarecord;
procedure fillname;
var j : integer;
begin
FTestData.Name[0] := #10;
for j := 1 to 10 do begin
FTestData.Name[j] := chr(random(26)+ 65) ; {A..Z}
end;
end;
var i : longint;
begin
for i := added +1 to added + 200 do begin
fillchar(FTestData,sizeof(FTestdata),#0);
fillname;
FTestData.anid := added + i;
panel1.caption := 'adding record: '+inttostr(i);
panel1.repaint;
Try
SUBDataBase1.addData_Indexe ([Index_Demo2],
[FTestData.Name],
Sizeof(FTestData),
FTestData);
except
{duplicate index are allowed!}
end;
if (i mod 25) = 0 then
Application.processmessages;
end;
inc(added,200);
showreccount;
showfirst := true;
end;
{----------------------------------------------------------------}
procedure TForm1.showreccount;
begin
panel1.caption := 'database has '+inttostr(SUBDataBase1.CountKeys(Index_Demo2 ))+' records';
end;
{----------------------------------------------------------------}
procedure TForm1.ButtonStatusClick(Sender: TObject);
Var SL : Tstringlist;
F : TStatusDialog;
begin
SL := Tstringlist.create;
SUBDataBase1.GetStatistik (SL);
F := TStatusDialog.create(NIL);
Try
f.memo1.lines := SL;
f.showmodal;
finally
f.free;
SL.free;
end;
end;
{----------------------------------------------------------------}
procedure TForm1.ButtondeleteClick(Sender: TObject);
var FTestData : TTestDatarecord;
i : longint;
begin
{-}
for i := 1 to 100 do begin
SUBDataBase1.FirstIndex (Index_Demo2 );
if SUBDataBase1.Datenid = -1 then break;
{no datas found}
SUBDataBase1.ReadActData ( sizeof(FTestData),FTestData);
SUBDataBase1.DeleteData_Indexe ([Index_Demo2],
[FTestData.name],
SUBDataBase1.Datenid);
panel1.caption := 'deleting record: '+inttostr(i);
panel1.repaint;
if (i mod 25) = 0 then
Application.processmessages;
end;
showreccount;
showfirst := true;
end;
{----------------------------------------------------------------}
procedure TForm1.SUBDataBase1Create(Sender: TObject);
begin
SUBDataBase1.createIndex (Index_Demo2 , 11, true);
{indexlength, duplicate}
end;
{----------------------------------------------------------------}
procedure TForm1.ButtonReorgClick(Sender: TObject);
begin
Subdatabase1.Reorganisation;
showreccount;
end;
{----------------------------------------------------------------}
procedure TForm1.SUBDataBase1Reorg(Sender: TObject; ReorgAct: Longint);
begin
panel1.caption := 'reorg: '+inttostr(ReorgAct)+' until: '+
inttostr(SUBDataBase1.Reorgmax);
Application.processmessages;
end;
{----------------------------------------------------------------}
procedure TForm1.ButtonshowClick(Sender: TObject);
var FTestData : TTestDatarecord;
i : integer;
begin
if showfirst then begin
SUBDataBase1.FirstIndex (Index_Demo2 );
showfirst := False;
end;
ListBox1.items.clear;
i := 1;
repeat
SUBDataBase1.ReadActData ( sizeof(FTestData),FTestData);
ListBox1.items.add(FTestData.name+'('+inttostr(FTestData.anid) +')');
inc(i);
SUBDataBase1.NextIndex (Index_Demo2, FTestData.name );
until (SUBDataBase1.DatenID = -1 )
or (i >100);
if SUBDataBase1.DatenID = -1 then showfirst := true;
end;
{----------------------------------------------------------------}
end.